package xml_helper;

#########################################################################
# Perl Object Module to generically parse XML into a more usable	#
# format.								#
#########################################################################

use XML::Parser;
use Carp qw(cluck);
use strict;
use Data::Dumper;

my $error_str=undef;
my $logmsg_hdlr=undef;
my $warnmsg_hdlr=undef;

sub error {
	return $error_str;
}

sub set_logmsg_hdlr {
	$logmsg_hdlr=$_[0];
}

sub set_warnmsg_hdlr {
	$warnmsg_hdlr=$_[0];
}

sub msg {
	if($_[0] eq "log" && defined($logmsg_hdlr)) {
		&{$logmsg_hdlr}($_[1]);
	}
	if($_[0] eq "warn" && defined($warnmsg_hdlr)) {
		&{$logmsg_hdlr}($_[1]);
	}
}

#########################################################################
# Class methods:							#
# ==============							#
# error - return latest error string or undef if everything was OK.	#
# set_logmsg_hdlr -  the routine to call to log a message - no logging	#
# 		     occurs if not set.					#
# set_warnmsg_hdlr - Issue a warning message via this routine - if	#
#		     available.						#
#########################################################################

#########################################################################
# 									#
# The new method does not expect any arguments since the contents to	#
# parse are expected to be passed as a string using the parse method.	#
#									#
#########################################################################

sub new {
my $self;
	#################################################################
	# Now load in the XML using the XML::Parser - not XML simple.	#
	#################################################################
	
	$self={};
	$self->{t}=undef;
	bless($self);
	return $self;
}

sub parse {
my $self=shift;
my $data=shift;
local $mond_xml::tree=undef;

	local %mond_xml::_h=();
	local $mond_xml::chash_ref;
	$error_str=undef;
	my $p;
	$p = new XML::Parser(
			Handlers => { Start => \&lc_handle_start,
					End => \&lc_handle_end,
				       Char => \&lc_handle_char },
			ErrorContext => 5
		);
	$error_str=undef;
	eval '$p->parse($data);';
	if($@) {
		$error_str=$@;
		return 0;
	}
	if(defined($error_str)) {
		cluck($error_str) if $::DEBUG;
		return 0;
	}
	$self->{t}={%mond_xml::_h};
	return 1;
}

sub lc_handle_start {
my $parser=shift;
my $element=shift;
my %attrs=(@_);
my @context=$parser->context;
my @required=qw(name hosts text routine);
my @optional=qw(mandatory optional);

	$element="\L$element";
	$mond_xml::__chardata="";

	#################################################################
	# Walk the context to get the latest tree component to 		#
	# update.							#
	#################################################################

	my $ch=\%mond_xml::_h;
	for my $c (@context) {
		my $l=0;
		while(exists($ch->{"e.$c.$l"})) {
			$l++;
		}
		$l--;
		$ch=$ch->{"e.$c.$l"};
	}

	#################################################################
	# So we look for all e.$element.n in $ch and add one ...	#
	#################################################################

	my $l=0;
	while(exists($ch->{"e.$element.$l"})) {
		$l++;
	}
	$ch->{"e.$element.$l"}={};
	$mond_xml::chash_ref=$ch->{"e.$element.$l"};
	$ch=$ch->{"e.$element.$l"};

	#################################################################
	# We can add all the attributes now...				#
	#################################################################

	for my $ckey (keys %attrs) {
		$ch->{"a.$ckey"}=$attrs{$ckey};
	}
}

sub lc_handle_end {
my $parser=shift;
my $element=shift;

	$mond_xml::__chardata =~ s/^\s+//g;	# Get rid of leading white
	$mond_xml::__chardata =~ s/\s+$//g;	# Get rid of trailing white space
	$mond_xml::__chardata =~ s/\n+$//g;	# Get rid of newlines white space
	if(length($mond_xml::__chardata)) {
		$mond_xml::chash_ref->{DATA}=$mond_xml::__chardata;
	}
}

sub lc_handle_char {
my $parser=shift;
my $str=shift;

	$mond_xml::__chardata.=$str;
	return ;
}

#########################################################################
# Once the tree has been defined a series of routines can be used to	#
# quickly gain access to the contents...				#
# get_element(name) - returns three items - data, attributes, elements.	#
#									#
# For example get_element("node_monitoring_configuration#0") would	#
# return "",{},["node_monitoring_configuration#0|monitor#0"]		#
# and then it would be possible to call:				#
# get_element("node_monitoring_configuration#0|monitor#0") and this	#
# would return three values:						#
# "",{name=>"swap",type=>"swap_space",interval=>"5 mins"},		#
# ["node_monitoring_configuration#0|monitor#0|instance#0",		#
#  "node_monitoring_configuration#0|monitor#0|instance#1"]		#
#									#
# So makes it very easy to walk the tree to get the stuff you want.	#
#########################################################################

sub get_element($$) {
my $self=shift;
my $xpath=shift;

	my $r=$self->{t};
	return undef if !defined($r);
	my @F=split(/\|/,$xpath);
	for my $cpart (@F) {
		my ($el,$num)=split(/#/,$cpart);
		$num="0" if ! defined($num);

		#########################################################
		# e.$el.$num should be a key in the current value of r,	#
		# and return undef if not.				#
		#########################################################
		if(!exists($r->{"e.$el.$num"})) {
			return undef;
		}
		$r=$r->{"e.$el.$num"};
	}

	#################################################################
	# Now $r is the one where we expect data, attributes and 	#
	# elements that should be returned to the user.			#
	#################################################################

	my $data="";
	if(exists($r->{DATA})) { 
		$data=$r->{DATA};
	}
	my @elements=();
	my %attrs=();

	for (sort(keys %$r)) {
		next if $_ eq "DATA";
		if(/^e\./) {
			my $x=substr($_,2); $x =~ s/\./#/;
			push @elements,"$xpath|$x";
		} else {
			my $x=substr($_,2); $x =~ s/\.\d+$//;
			$attrs{$x}=$r->{$_};
		}
	}
	return ($data,{%attrs},[@elements]);
}

sub string_to_xml {
my $self=shift;
my $s=shift;

	# We convert the following into sensible XML...
	# & " < >
	# We do this by changed &amp; back to & and then convert back
	# since this is the easiest way not to change &amp; to &amp;amp ...

	$s =~ s/\&amp;/\&/g;
	$s =~ s/\&quot;/\"/g;
	$s =~ s/\&lt;/\</g;
	$s =~ s/\&gt;/\>/g;

	$s =~ s/\&/\&amp;/g;
	$s =~ s/\"/\&quot;/g;
	$s =~ s/\</\&lt;/g;
	$s =~ s/\>/\&gt;/g;

	return $s;
}

1;

